C   HS104   10-2730
      BLOCK DATA
      INCLUDE 'BLOCO.INC'
      INTEGER I,J
      DATA NAME/'HS104'/
      DATA (X(I),I=1,8)/6.D0,3.D0,.4D0,.2D0,2*6.D0,1.D0,.5D0/
      DATA N/ 8/ , NH/0/ , NG/22/
      DATA DEL0/1.00D0/ ,TAU0/1.D4/ ,TAU/.1D0/
      DATA (GUNIT(1,I),I=1,6)/6*-1/,((GUNIT(I,J),I=2,3),J=1,6)/12*0/,
     F     (GUNIT(1,I),I=7,22)/16*1/,(GUNIT(2,I),I=7,22)/1,2,3,4,5,6,
     F     7,8,1,2,3,4,5,6,7,8/,(GUNIT(3,I),I=7,14)/8*1/,
     F     (GUNIT(3,I),I=15,22)/8*-1/  
      END
      SUBROUTINE EF(X,FX)
      INCLUDE 'FUCO.INC'
      INTEGER I,KF(2,2)
      DOUBLE PRECISION FX,X(NX),DL(NX),ALF(2,2),GAMF(2)
      SAVE KF,GAMF,ALF,DL
      DATA KF/1,7,2,8/
      DATA GAMF/2*.4D0/
      DATA ALF/.67D0,-.67D0,.67D0,-.67D0/
      DATA (DL(I),I=1,8)/2*-1.D0,6*0.D0/
      ICF=ICF+1
      CALL FGEO(X,10.D0,GAMF,.TRUE.,DL,KF,ALF,2,2,8,FX)
      RETURN
      END
      SUBROUTINE EGRADF(X,GRADF)
      INCLUDE 'FUCO.INC'
      INTEGER I,KF(2,2)
      DOUBLE PRECISION X(NX),DL(NX),ALF(2,2),GAMF(2),GRADF(NX)
      SAVE KF,GAMF,ALF,DL
      DATA KF/1,7,2,8/
      DATA GAMF/2*.4D0/
      DATA ALF/.67D0,-.67D0,.67D0,-.67D0/
      DATA (DL(I),I=1,8)/2*-1.D0,6*0.D0/
      ICGF=ICGF+1
      CALL DFGEO(X,GAMF,.TRUE.,DL,KF,ALF,2,2,GRADF,8)
      RETURN
      END
      SUBROUTINE EH(I,X,HXI)
      INCLUDE 'FUCO.INC'
      DOUBLE PRECISION  X(*),HXI
      INTEGER I
      CRES(I)=CRES(I)+1
      RETURN
      END
      SUBROUTINE EGRADH(I,X,GRADHI)
      INCLUDE 'FUCO.INC'
      INTEGER I
      DOUBLE PRECISION X(*),GRADHI(*)
      CGRES(I)=CGRES(I)+1
      RETURN
      END
      SUBROUTINE EG(I,X,GXI)
      INCLUDE 'FUCO.INC'
      INTEGER I
      DOUBLE PRECISION GXI
      DOUBLE PRECISION X(*),DL(NX),ALF(2,2),GAMF(2)
      DOUBLE PRECISION GAM1(3),AL1(2,3)
      INTEGER J,KF(2,2),K1(2,3),K2(2,3)
      SAVE KF,K1,K2,ALF,GAMF,GAM1,AL1,DL
      DATA KF/1,7,2,8/
      DATA GAMF/2*.4D0/
      DATA ALF/.67D0,-.67D0,.67D0,-.67D0/
      DATA (DL(J),J=1,8)/2*-1.D0,6*0.D0/
      DATA GAM1/-4.D0,-2.D0,-.0588D0/
      DATA AL1/1.D0,-1.D0,-.71D0,-1.D0,-1.3D0, 1.D0/
      DATA K1/3,5,3,5,3,7/
      DATA K2/4,6,4,6,4,8/
      IF ( I.LE. 6 ) CRES(I+NH)=CRES(I+NH)+1
      IF(I .GT. 6)      GOTO 700
      GOTO (100,200,300,400,500,600),I
  100 CONTINUE
      GXI=1.D0-.0588D0*X(5)*X(7)-.1D0* X(1)
      RETURN
  200 CONTINUE
      GXI=1.D0-.0588D0*X(6)*X(8)-.1D0*(X(1)+X(2))
      RETURN
  300 CONTINUE
      CALL FGEO(X,1.D0,GAM1,.FALSE.,DL,K1,AL1,2,3,8,GXI)
      RETURN
  400 CONTINUE
      CALL FGEO(X,1.D0,GAM1,.FALSE.,DL,K2,AL1,2,3,8,GXI)
      RETURN
  500 CONTINUE
      CALL FGEO(X, 9.D0,GAMF,.TRUE.,DL,KF,ALF,2,2,8,GXI)
      RETURN
  600 CONTINUE
      CALL FGEO(X, 5.8D0,GAMF,.TRUE.,DL,KF,ALF,2,2,8,GXI)
      GXI=-GXI
      RETURN
  700 CONTINUE
      IF( I .LE. 14)    GXI=X(I-6)- .1D0
      IF( I .GT. 14)    GXI=10.D0-X(I-14)
      END
      SUBROUTINE EGRADG(I,X,GRADGI)
      INCLUDE 'FUCO.INC'
      INTEGER I
      DOUBLE PRECISION X(NX),GRADGI(NX)
      DOUBLE PRECISION DL(NX),ALF(2,2),GAMF(2)
      DOUBLE PRECISION  GAM1(3),AL1(2,3)
      INTEGER J,KF(2,2),K1(2,3),K2(2,3)
      SAVE KF,K1,K2,GAMF,ALF,DL,GAM1,AL1
      DATA KF/1,7,2,8/
      DATA GAMF/2*.4D0/
      DATA ALF/.67D0,-.67D0,.67D0,-.67D0/
      DATA (DL(J),J=1,8)/2*-1.D0,6*0.D0/
      DATA GAM1/-4.D0,-2.D0,-.0588D0/
      DATA AL1/1.D0,-1.D0,-.71D0,-1.D0,-1.3D0, 1.D0/
      DATA K1/3,5,3,5,3,7/
      DATA K2/4,6,4,6,4,8/
      IF ( I .GT. 6 ) RETURN
      CGRES(I+NH)=CGRES(I+NH)+1
      DO      100      J=1,8
      GRADGI(J)=0.D0
  100 CONTINUE
      IF(I .GT. 6)      GOTO 800
      GOTO (200,300,400,500,600,600),I
  200 CONTINUE
      GRADGI(1)=-.1D0
      GRADGI(5)=-.0588D0*X(7)
      GRADGI(7)=-.0588D0*X(5)
      RETURN
  300 CONTINUE
      GRADGI(1)=-.1D0
      GRADGI(2)=-.1D0
      GRADGI(6)=-.0588D0*X(8)
      GRADGI(8)=-.0588D0*X(6)
      RETURN
  400 CONTINUE
      CALL DFGEO(X,GAM1,.FALSE.,DL,K1,AL1,2,3,GRADGI,8)
      RETURN
  500 CONTINUE
      CALL DFGEO(X,GAM1,.FALSE.,DL,K2,AL1,2,3,GRADGI,8)
      RETURN
  600 CONTINUE
      CALL DFGEO(X,GAMF,.TRUE.,DL,KF,ALF,2,2,GRADGI,8)
      IF( I .EQ. 5)       RETURN
      DO      700      J=1,8
      GRADGI(J) =-GRADGI(J)
  700 CONTINUE
      RETURN
  800 CONTINUE
      IF( I .LE. 14)    GRADGI(I-6)=1.D0
      IF( I .GT. 14)    GRADGI(I-14)=-1.D0
      RETURN
      END
C****************************************************************
      SUBROUTINE FGEO(X,CON,GAM,LIN,DL,K,AL,NLEN,NANZ,NX,FX)
      IMPLICIT NONE
      DOUBLE PRECISION CON,FX,P,S,EXPO
      INTEGER NLEN,NANZ,NX,I,J,IL
      DOUBLE PRECISION GAM(NANZ),AL(NLEN,NANZ),X(NX),DL(NX)
      INTEGER K(NLEN,NANZ)
      LOGICAL LIN
      S=CON
      IF(.NOT. LIN)      GOTO 200
      DO      100      I=1,NX
      S=S+DL(I)*X(I)
  100 CONTINUE
  200 CONTINUE
      DO      600      I=1,NANZ
      IF(GAM(I) .EQ. 0.D0)      GOTO 600
      P=1.D0
      DO      500      J=1,NLEN
      IL=K(J,I)
      IF(IL .EQ. 0)      GOTO 500
      EXPO=AL(J,I)
      IF(EXPO .EQ. 0.D0)      GOTO 500
      P=P*DEXP(EXPO*DLOG(DABS(X(IL))))
  500 CONTINUE
      S=S+GAM(I)*P
  600 CONTINUE
      FX=S
      RETURN
      END
      SUBROUTINE DFGEO(X,GAM,LIN,DL,K,AL,NLEN,NANZ,G,NX)
      IMPLICIT NONE
      DOUBLE PRECISION FC,FIJ,P,S,EXPO
      INTEGER NLEN,NANZ,NX,I,J,IL,L
      DOUBLE PRECISION GAM(NANZ),AL(NLEN,NANZ),X(NX),
     F          G(NX),DL(NX)
      INTEGER K(NLEN,NANZ)
      LOGICAL LIN
      DO      500      L=1,NX
      S=0.D0
      DO      400      I=1,NANZ
      IF(GAM(I) .EQ. 0.D0)     GOTO 400
      P=1.D0
      FC=0.D0
      DO      300      J=1,NLEN
      IL=K(J,I)
      IF(IL .EQ. 0)      GOTO 300
      IF(IL .NE. L)      GOTO 100
      FC=1.D0
  100 CONTINUE
      EXPO=AL(J,I)
      IF(EXPO .EQ. 0.D0)      GOTO 300
      FIJ=1.D0
      IF(IL .NE. L)      GOTO 200
      FIJ=EXPO
      EXPO=EXPO-1.D0
  200 CONTINUE
      P=P*FIJ*DEXP(EXPO*DLOG(DABS(X(IL))))
  300 CONTINUE
      IF(FC .NE. 0.D0)    S=S+P*GAM(I)
  400 CONTINUE
      IF(LIN)    S=S+DL(L)
      G(L)=S
  500 CONTINUE
      RETURN
      END
      SUBROUTINE SETUP
      RETURN
      END
